Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/pcl/cl-nd-cl.lha/clue/clio/slider.lisp

Text File | 1990-07-19 | 44.8 KB | 1,115 lines

;; -*- Mode:Lisp; Package:CLIO-OPEN; Base:10; Lowercase:T; Fonts:(CPTFONT); Syntax:Common-Lisp;  -*-


;;;----------------------------------------------------------------------------------+
;;;                                                                                  |
;;;                          TEXAS INSTRUMENTS INCORPORATED                          |
;;;                                  P.O. BOX 149149                                 |
;;;                                AUSTIN, TEXAS 78714                               |
;;;                                                                                  |
;;;             Copyright (C) 1989, 1990 Texas Instruments Incorporated.             |
;;;                                                                                  |
;;; Permission is granted to any individual or institution to use, copy, modify, and |
;;; distribute this software, provided that  this complete copyright and  permission |
;;; notice is maintained, intact, in all copies and supporting documentation.        |
;;;                                                                                  |
;;; Texas Instruments Incorporated provides this software "as is" without express or |
;;; implied warranty.                                                                |
;;;                                                                                  |
;;;----------------------------------------------------------------------------------+


(in-package "CLIO-OPEN")

(export '(
      make-slider
      slider
      )
    'clio-open)

(defmacro translate-x-to-y (x x-width slider)
  "Translate x coord for horizontal slider into y of a vertical slider.
X-WIDTH is the width in x-direction that must be changed into a y-offset."
  `(with-slots (height) ,slider
     (- height 1 ,x (max 0 (1- ,x-width)))))


(defmacro confine-to (value minimum maximum)
  `(max ,minimum (min ,value ,maximum)))


(defmacro align (value increment)
  ;; Since we are talking SCALE VALUE here
  ;; we pixel-round since it may be a REAL number.
  `(if (= 1 ,increment)
       ,value
       (* (pixel-round ,value ,increment) ,increment)))


(defmacro value-length (value minimum)
  `(- ,value ,minimum))

;;;----------------------------------------------------------------------------+
;;;                                                                            |
;;;                             Slider                                         |
;;;                                                                            |
;;;----------------------------------------------------------------------------+


;; Implementation Strategy:
;;
;;  Since CLIO should implement a "look and
;; feel" independent implemementation of open-look, then only those
;; parts of the slider that are going to exist in most implemementations
;; will be supported.  Since make-slider accepts :
;; (increment indicator-size maximum minimum orientation update-delay value compress-exposures)
;; then all "features" must be derived from these inputs.
;;
;;  To provide numeric visual feedback of the current value is desirable,
;; but providing this as a typein field or read-only field really requires a label
;; or else the displayed result is somewhat confusing.
;;  The current value will be implemented as AUTOMATIC tick-marks and tick-mark
;; labels based on the min-max values and the space available to print them. The
;; actual current value will not be printed but will be discernable by "reading the scale".
;;
;; Thus the slider parts implemented are :
;;     (bar, drag-box, (automatic) tick-marks, (automatic) tick-text)
;; and the following will NOT be provided :
;;      (End boxes, labels, typein fields, non-numeric text of any kind)
;; This means that the read-only min-max current-value fields will be provided only by way
;; of the min-/max tick-mark tick-text labels.
;;
;;  When horizontal sliders require max (or min) values of more than 2 digits
;; then the tick-mark & tick-mark-number-labels are difficult to display. In this
;; case a :vertical orientation is more appropriate. If more than 2-digits are used
;; for a :horizontal slider then the tick-mark granularity will be reduced in order
;; to accommodate the width of the digits.
;;

(defcontact slider (core contact)
  ((increment     :type         number
         :reader        scale-increment        ;; SETF method defined below
        :initarg    :increment
         :initform     1)

   (indicator-size        ;; The size of the distance between tick-marks in value units.
                                ;; :off means "no tickmarks or tick labels", 1 will cause tick-mark
                    ;; overlap if there is not enough space to display. [2..N] will
                ;; cause a tick-spacing of [1..(1- N)].
                ;;
                :type         (or number (member :off)) ;; 0 means "automatic" tick mark spacing.
        :reader        scale-indicator-size    ;; SETF method defined below
        :initarg    :indicator-size
        :initform     0)

   (maximum     :type         number
         :reader        scale-maximum        ;; SETF method defined below
        :initarg    :maximum
         :initform     1)

   (minimum     :type         number
         :reader        scale-minimum        ;; SETF method defined below
        :initarg    :minimum
         :initform     0)

   (orientation :type         (member :horizontal :vertical)
         :reader        scale-orientation    ;; SETF method defined below
        :initarg    :orientation
         :initform     :horizontal)

   (update-delay :type        (or number (member :until-done))
         :reader    scale-update-delay    ;; SETF method defined below
         :initarg    :update-delay
         :initform    0)

   (value     :type         number
         :reader        scale-value    ;; SETF method defined below
        :initarg    :value
         :initform     0)

   (compress-exposures
                :initform       :on
        :type           (member :off :on)
        :reader         contact-compress-exposures
        :allocation     :class)

   ;; Internal storage slots
   (font        :type    fontable);; font for current scale

   (min-text-width :type    number)     ;; pixel width of minimum value print string

   (max-text-width :type    number)     ;; pixel width of maximum value print string

   (dimensions       :type    list)    ;; (getf *slider-dimensions* scale)

   (middle-length  :type        number)     ;; pixel length between first & last tick marks
   )

  (:resources
    increment indicator-size maximum minimum orientation update-delay value
    (border-width :initform 0)
    (event-mask   :initform #.(make-event-mask :exposure :pointer-motion-hint))))


;;;----------------------------------------------------------------------------+
;;;                                                                            |
;;; Setf Accessors                                                             |
;;;                                                                            |
;;;----------------------------------------------------------------------------+

(defmethod (setf scale-orientation) (new-orientation (slider slider))
  (with-slots (orientation width height) slider
    (unless (eq orientation new-orientation)
      (check-type new-orientation (member :horizontal :vertical))

      (setf orientation new-orientation)

      (multiple-value-bind (new-width new-height)
      (preferred-size slider :width height :height width)
    (change-geometry slider :width new-width :height new-height :accept-p t))))

  new-orientation)

(defmethod (setf scale-update-delay) (new-update-delay (slider slider))
  (with-slots (update-delay) slider
    (assert (or (eq new-update-delay :until-done)
        (and (numberp new-update-delay) (not (minusp new-update-delay)))) (new-update-delay)
        "~a is neither :UNTIL-DONE or a non-negative number." new-update-delay)
    (setf update-delay new-update-delay)))

(defmethod (setf scale-value) (new-value (slider slider))
  (scale-update slider :value new-value)
  new-value)

(defmethod (setf scale-minimum) (new-minimum (slider slider))
  (scale-update slider :minimum new-minimum)
  new-minimum)

(defmethod (setf scale-maximum) (new-maximum (slider slider))
  (scale-update slider :maximum new-maximum)
  new-maximum)

(defmethod (setf scale-increment) (new-increment (slider slider))
  (scale-update slider :increment new-increment)
  new-increment)

(defmethod (setf scale-indicator-size) (new-indicator-size (slider slider))
  (scale-update slider :indicator-size new-indicator-size)
  new-indicator-size)


;;;------------------------------------------------------------------------------------+
;;;                                                                                    |
;;;      Helper Functions                                                             |
;;;                                                                                    |
;;;------------------------------------------------------------------------------------+

(defun slider-tick-mark-thickness (slider)
  (if (eq :extra-large (contact-scale slider))
      3
      2))

(defun slider-bar-tick-gap (slider)
  ;; Distance top of tick-mark and nearest point on bar
  (1+ (case (contact-scale slider)
    (:small 1) (:medium 2) (:large 3) (:extra-large 4))))

(defun slider-margin (slider margin)
  "Returns the MARGIN of SLIDER, one of :min :top :text :max"
  ;; This is initially *slider-default-margin* until
  ;; after the PREFERRED-SIZE method is called. Then margins include
  ;; any additional increase due to a width or height larger than the
  ;; preferred size. :LEFT means the left margin for this particular orientation.
  (assert (member margin '(:min :top :text :max)) (margin)
      "~a is an illegal margin" margin)
    (let ((margins (getf (getf (window-plist slider) :slider-info) :margins)))
      (or (getf margins margin)
      ;;  Calling before margins are setup is never
      ;;  done but code is here for completeness
      *slider-default-margin*)))

(defun first-tick-offset (slider)
  ;; Offset, not including (slider-margin slider :min), from
  ;; min edge of contact to CENTERLINE of first tick-mark.
  (with-slots (min-text-width orientation font dimensions indicator-size) slider
    (let ((tick-mark-offset (slidebar-tick-mark-offset dimensions))
       (gap (slidebar-gap dimensions)))
      (+ *slider-default-margin*
     ;;  Add GAP below since drag-box clear-gap-around extends past bar edge
     (if (eq :off indicator-size)
         (+ gap tick-mark-offset)
         (if (eq orientation :horizontal)
         (max (floor min-text-width 2) (+ gap tick-mark-offset))
         (+ gap tick-mark-offset) ;; the text baseline is ALWAYS above end of bar MIN
         ))))))

(defun last-tick-offset (slider)
  ;; Offset, not including (slider-margin slider :max), from
  ;; max edge of contact to CENTERLINE of last tick-mark.
  (with-slots (max-text-width orientation font dimensions indicator-size) slider
    (let ((tick-mark-offset (slidebar-tick-mark-offset dimensions))
      (gap (slidebar-gap dimensions)))
      (+ *slider-default-margin*
     ;;  Add GAP below since drag-box clear-gap-around extends past bar edge
     (if (eq :off indicator-size)
         (+ gap tick-mark-offset)
         (if (eq orientation :horizontal)
         (max (ceiling max-text-width 2) (+ gap tick-mark-offset))
         (+ tick-mark-offset
            (max gap
             ;; font-ascent may go beyond end of bar MAX if font is bigger than "point" requested
             (abs (- (cadr (getf (slidebar-bar-text-offset dimensions) orientation))
                 (max-char-ascent font)
                 ))))))))))


;;
;;
;;  Pixels :                          Scale Units :
;;
;; middle-length                   (- maximum minimum)
;;
;;  [MAX]
;;    |
;;    |
;;    |              proportional       [MAX]
;;    |    -                              |
;;    |                                   |
;;    |   Pixel-delta                     |    -
;;    |                                   |    Scale-delta
;;    |                                   |
;;  [MIN]  -                            [MIN]  -
;;
;;    0                                 minimum
;;
;; Since :
;;
;; pixel-delta / middle-length = scale-delta / (- maximum minimum)
;;
;; Then :
;;
;; Pixel-delta = (* scale-delta middle-length) / (- maximum minimum)
;;
;; And :
;;
;; Scale-delta = (* pixel-delta (- maximum minimum)) / middle-length
;;
(defun units-to-pixels (slider scale-delta)
  ;; Convert a scale delta to a pixel delta
  (with-slots (minimum maximum middle-length) slider
    (pixel-round (/ (* scale-delta middle-length)
          (- maximum minimum)))))

(defun pixels-to-units (slider pixel-delta)
  (with-slots (orientation minimum maximum increment middle-length) slider
    ;; Convert a pixel delta to a scale units delta
    ;; *DON'T* round this - units may be fractional !
    (/ (* pixel-delta (- maximum minimum))
       middle-length)))

;; NOTE: The functions named ????-x and below return values strictly for a :horizontal
;; slider and the return values must be translated for a :vertical slider.

(defun first-tick-x (slider)
  (+ (slider-margin slider :min)
     (first-tick-offset slider)))


(defun drag-box-center-x (slider &optional (scale-value (scale-value slider)))
  (with-slots (minimum) slider
    ;; Returns dead center of drag-box
    (+ (first-tick-x slider)
       ;; Must subtract minimum since minimum can be negative and is NOT always zero!
       (units-to-pixels slider (value-length scale-value minimum)))))


(defun drag-box-min-x (slider &optional (scale-value (scale-value slider)))
  (with-slots (dimensions minimum maximum) slider
    (let* ((drag-box-width (slidebar-drag-box-width dimensions))
       (gap (slidebar-gap dimensions)))
      (- (drag-box-center-x slider scale-value)
     (floor drag-box-width 2)
     gap ;; subtract whitespace gap around drag-box
     ))))

(defun drag-box-position (slider &optional (scale-value (scale-value slider)))
  (declare (values x y width height))
  (with-slots (orientation ) slider
    ;; Return values describing area of drag-box for SCALE-VALUE
    (let* ((drag-min-edge (drag-box-min-x slider scale-value))
       (drag-image (getf (getf *slider-drag-box-images* orientation)
                 (contact-scale slider))))

      (if (eq orientation :horizontal)
      (values drag-min-edge
          (+ (slider-margin slider :top) *slider-default-margin*)
          (image-width drag-image)
          (image-height drag-image))
      (values (+ (slider-margin slider :top) *slider-default-margin*)
          (translate-x-to-y drag-min-edge (image-height drag-image) slider)
          (image-width drag-image)
          (image-height drag-image)))
      )))


(defmethod scale-update ((slider slider) &key value minimum maximum indicator-size increment)
  ;; Called by (method initialize-instance :after (slider)) to do error checking, and by
  ;; SETF methods for slots in arglist above, and by (setf scale-value) called to move slider.
  (with-slots
    ((current-val value)
     (current-min minimum)
     (current-max maximum)
     (current-ind indicator-size)
     (current-inc increment)
     orientation min-text-width max-text-width font)
    slider
    (let ((old-val (and value current-val)) ;; old-value & flag that value was passed in.
      (old-min (and minimum current-min))
      (old-max (and maximum current-max))
      (old-inc (and increment current-inc))
      (old-ind (and indicator-size current-ind)))

      (setf minimum        (or minimum current-min)
        maximum        (or maximum current-max)
        value          (or value (confine-to current-val minimum maximum))
        indicator-size (or indicator-size current-ind)
        increment      (or increment current-inc))

      (assert (and (numberp minimum) (numberp maximum)
           (< minimum maximum))
          (minimum maximum)
          "Minimum (~a) is not less than maximum (~a)."
          minimum maximum)

      (assert (and (numberp value)
           (<= minimum value maximum))
          (value)
          "Value (~a) must be in the range [~a, ~a]."
          value minimum maximum)

      (assert (or (eq :off indicator-size)
          (and (numberp indicator-size)
               (not (minusp indicator-size))))
          (indicator-size)
          "Indicator-size (~a) must be :OFF, 0, or a positive number."
          indicator-size)

      (assert (and (numberp increment)
           (< 0 increment (1+ (- maximum minimum))) ;; allow fractional increments, allow increment = maximum
           (zerop (mod (- maximum minimum) increment)))
          (increment)
          "Increment (~a) must be in the range [0 ~a] and a factor of ~:*~d."
          increment (- maximum minimum))

      ;;  Once VALUE & INCREMENT are valid we can align VALUE, if necessary,
      ;;  to be a multiple of INCREMENT.
      (setq value (+ minimum (align (value-length value minimum) increment)))

      (setf current-min minimum
        current-max maximum
        current-val value
        current-ind indicator-size
        current-inc increment
        min-text-width (text-extents font (format nil "~a" minimum))
        max-text-width (text-extents font (format nil "~a" maximum)))

      ;; Redisplay drag-box and any changes
      (when (realized-p slider)
    (cond ((or (and old-min
            (not (= old-min current-min)))
           (and old-max
            (not (= old-max current-max)))
           (and old-ind
            (not (eq old-ind current-ind)))
           (and old-inc
            (not (= old-inc current-inc))))
           (clear-area slider :exposures-p t))

          ((and old-val ;; when called with NEW increment value
            (not (= old-val current-val))) ;; when something has changed

           ;; Compute area of old drag-box ( if any )
           (multiple-value-bind (old-x old-y old-width old-height)
           (drag-box-position slider old-val)

         ;; Compute area of new drag-box
         (multiple-value-bind (x y width height)
             (drag-box-position slider current-val)

           ;; Merge areas to redisplay : new drag-box, bar between old & new,
           ;; old drag-box ( if any ), & tick marks obscured by drag-box
           (when old-val
             (if (eq orientation :horizontal)
             (setf width (+ (abs (- x old-x)) (max old-width width))
                   x (min x old-x))
             (setf height (+ (abs (- y old-y)) (max old-height height))
                   y (min y old-y))))
           (clear-area slider :x x :y y :width width :height height)
           (display slider x y width height))))
          (t)))
      )))


;;;----------------------------------------------------------------------------+
;;;                                                                            |
;;;                            Initialization                                  |
;;;                                                                            |
;;;----------------------------------------------------------------------------+

(defun make-slider (&rest initargs &key &allow-other-keys)
  (apply #'make-contact 'slider initargs))

(defun bar-bottom-offset (slider)
  ;; Offset from the top (left) of horizontal (vertical) slider
  ;; ... does NOT include (slider-margin slider :top) ...
  ;; and 1-pixel past the bottom (right) edge of the slidebar
  (with-slots (dimensions) slider
    (+ *slider-default-margin*
       (slidebar-gap dimensions)
       (slidebar-bar-drag-offset dimensions)
       (slidebar-bar-thickness dimensions))))

(defun fixed-thickness (slider &key include-text-p)
  ;; The minimum thickness of slider required for the
  ;; scale, orientation, and string characteristics of the minimum & maximum
  (with-slots (orientation min-text-width max-text-width
             indicator-size dimensions font) slider
    (let ((x (first  (getf (slidebar-bar-text-offset dimensions) orientation)))
      (y (second (getf (slidebar-bar-text-offset dimensions) orientation)))
      (scale (contact-scale slider)))
      (if (eq :off indicator-size)
      (+ *slider-default-margin*
         (if (eq orientation :horizontal)
         (image-height (getf (getf *slider-drag-box-images* orientation) scale))
         (image-width  (getf (getf *slider-drag-box-images* orientation) scale)))
         *slider-default-margin*) ;; no space allocated for tick marks & text
      ;; else
      (if (eq orientation :horizontal)
          (+ (bar-bottom-offset slider) y
         (if include-text-p
             (+ (max-char-descent font) *slider-default-margin*)
             0))
          (+ (bar-bottom-offset slider) x
         (if include-text-p
             (+ (max min-text-width max-text-width) *slider-default-margin*)
             0)))))))

(defun slider-compute-margins (slider)
  ;;  Now margins can be computed from the delta between the size needed and the
  ;;  size we were given. The length of the slider basically stretches to fit but
  ;;  any extra height results in the slider being centered in space provided.
  ;;  PREFERRED-SIZE (via initialize-instance :after) MUST have been called to
  ;;  set WIDTH & HEIGHT by this time.
  (with-slots (orientation width height middle-length) slider
    (let* ((total-min-thickness (fixed-thickness slider :include-text-p t))
       (size          (if (eq orientation :horizontal) height width))
       (top-margin    (floor (- size total-min-thickness) 2))
       (bottom-margin (- size total-min-thickness top-margin)))

      (setf (getf (getf (window-plist slider) :slider-info) :margins)
        ;; left top bottom right (horizontal)
        (list :min 0 :top top-margin :text bottom-margin :max 0))

      ;; With margins set we can now compute and save middle-length for efficiency
      (setf middle-length
        (- (if (eq :horizontal orientation)
           width
           height)
           (slider-margin slider :min)
           (first-tick-offset slider)
           (last-tick-offset slider)
           (slider-margin slider :max)
           )))))


(defmethod initialize-instance :after ((slider slider) &key &allow-other-keys)
  (with-slots (font width height minimum maximum
            dimensions min-text-width max-text-width) slider

    (setq font (find-font slider *default-display-text-font*)
      dimensions (getf *slider-dimensions* (contact-scale slider)))

    (scale-update slider) ;; do some error checking, set min-text-width, etc.

    ;;  Initialize required geometry
    (multiple-value-setq (width height) (preferred-size slider))

    ;; Compute margins now that WIDTH & HEIGHT are known
    (slider-compute-margins slider)
    ))


;;;----------------------------------------------------------------------------+
;;;                                                                            |
;;;                        Geometry Management                                 |
;;;                                                                            |
;;;----------------------------------------------------------------------------+


(DEFMETHOD rescale :before ((slider slider))
  (with-slots (font dimensions) slider
    (setf font (find-font slider  *default-display-text-font*)
      dimensions (getf *slider-dimensions* (contact-scale slider)))
    (slider-compute-margins slider)
    ))


(defmethod resize :after ((slider slider) new-width new-height new-border-width)
  ;; This method duplicates calculations started in (method initialize-instance :after (slider))
  ;; but are done here since they also must be performed when change-geometry is invoked.
  ;; Called when window-manager or someone else calls change-geometry.
  (declare (ignore new-width new-height new-border-width))
  (slider-compute-margins slider))


(defmethod preferred-size ((slider slider) &key width height border-width)
  (declare (ignore border-width)) ;; preferred-border-width is 0
  (with-slots (orientation min-text-width max-text-width font dimensions indicator-size
               (current-height height) (current-width width)) slider
    (let* ((drag-box-width   (slidebar-drag-box-width dimensions))
       (tick-mark-offset (slidebar-tick-mark-offset dimensions))

       ;;  Min width  of slider with 2 positions = double size of drag box
       (minimum-double-width
         (+ (- (first-tick-offset slider) tick-mark-offset)
        (max (* 2 drag-box-width)
             (if (eq :off indicator-size)
             0
             (if (eq orientation :horizontal)
                 ;; room needed to display text between first/last-tick
                 (+ (ceiling min-text-width 2)
                (max-char-descent font)
                (floor max-text-width 2))
                 ;; room needed to display 2 text lines (min & max) vertically,
                 ;; plus a small gap between
                 (+ (max-char-ascent font)
                (max-char-descent font) ;; gap between
                (max-char-ascent font)))))
        (- (last-tick-offset slider) tick-mark-offset)))

       ;; Calculate geometry assuming :horizontal orientation
       (preferred-height
         (max
           ;; Suggested or current height
           (if (eq orientation :horizontal)
           (or height current-height)
           (or width current-width))

           ;; Total thickness of horizontal bar
           (fixed-thickness slider :include-text-p t)))

       (preferred-width
         (max
           ;; Suggested or current width
           (if (eq orientation :horizontal)
           (or width current-width)
           (or height current-height))

           minimum-double-width))
       )

      ;; Return preferred geometry according to actual orientation
      (if (eq orientation :horizontal) ;; preferred-border-width is always 0
      (values preferred-width preferred-height 0)
      (values preferred-height preferred-width 0))
    )))

;;;----------------------------------------------------------------------------+
;;;                                                                            |
;;;                          Event Translations                                |
;;;                                                                            |
;;;----------------------------------------------------------------------------+

(defevent slider (:button-press :button-1)   slider-press)
(defevent slider (:button-release :button-1) slider-release)
(defevent slider (:motion-notify :button-1)  slider-handle-motion)

(defun slider-release (slider)
  (declare (special *slider-pressed-p*))
  (when (boundp '*slider-pressed-p*)
    (throw-action slider :release t)))

(defun highlite-drag-box (slider gc x y width height gap)
  (draw-rectangle slider gc (+ gap 1 gap x) (+ gap 1 gap y)
          (- width (* 4 gap) 3) (- height (* 4 gap) 3) :fill-p))

(defun slider-press (slider)
  (with-event (x y)

    (with-slots
      (foreground orientation update-delay minimum maximum
       increment width height display value dimensions)
      slider

      (let (*slider-pressed-p* )
    (declare (special *slider-pressed-p*))

    (multiple-value-bind (drag-x drag-y drag-width drag-height)
      (drag-box-position slider)

    (when
      (cond
        ((and (>= x drag-x) (< x (+ drag-x drag-width))
          (>= y drag-y) (< y (+ drag-y drag-height)))

         ;; SELECT on drag box
         (let ((*highlight-pixel* (logxor foreground (contact-current-background-pixel slider)))
           (gap (slidebar-gap dimensions)))
           (declare (special *highlight-pixel*)) ;; use this in display method while moving ..
           (using-gcontext
         (gc :drawable slider
             :function boole-xor
             :foreground *highlight-pixel*)

         ;; Highlight drag area
         (highlite-drag-box slider gc drag-x drag-y drag-width drag-height gap)

         ;; Set timer for update
         (when (and (numberp update-delay) (plusp update-delay))
           (add-timer slider :update-delay update-delay))

         (apply-callback slider :begin-continuous)
         (catch :release
           (let ((*previous-position* (if (eq :vertical orientation) y x)))
             (declare (special *previous-position*))
             (loop (process-next-event display))))
         (apply-callback slider :end-continuous)

         ;; Unhighlight drag area.
         (multiple-value-bind (new-drag-x new-drag-y)
             (drag-box-position slider)
           (highlite-drag-box slider gc new-drag-x new-drag-y drag-width drag-height gap))))
         t)

      ;;  SELECT on bar
      ;;  Since it is NOT in drag-box, just check if it is in bar
      ;;  or the area of the bar if it had the thickness of the drag-box.
      ;;  This makes clicking somewhat easier.
      ((multiple-value-bind (bar-x bar-y bar-width bar-height)
           (if (eq orientation :horizontal)
           (values (slider-margin slider :min) (slider-margin slider :top)
               (- width (slider-margin slider :min) (slider-margin slider :max))
               drag-height)
           (values (slider-margin slider :top) (slider-margin slider :min)
               drag-width
               (- height (slider-margin slider :min) (slider-margin slider :max))))
         (and (>= x bar-x) (>= y bar-y)
          (< x (+ bar-x bar-width))
          (< y (+ bar-y bar-height))))

       ;; Advance drag-box one increment in direction indicated.
       ;; User may click so fast that the drag box passes the click
       ;; position, thus inadvertently reversing the increment direction.
       ;; Synchronize by using current pointer position, not click position.
       (multiple-value-bind (ptr-x ptr-y) (pointer-position slider)

         (let ((delta (if (if (eq orientation :horizontal)
                  (< ptr-x drag-x)
                  (>= ptr-y (+ drag-y drag-height)))
                  (- increment)
                  increment))
           (gap   (slidebar-gap dimensions)))

           (slider-increment-value slider delta)

           ;; Must warp pointer to stay in MIN (or MAX) bar, if necessary
           (multiple-value-bind (new-drag-x new-drag-y drag-width drag-height)
           (drag-box-position slider)

         (multiple-value-bind (warp-x warp-y)
             (if (eq orientation :horizontal)
             (if (plusp delta)
                 (let ((min-x (min (1- width) (+ new-drag-x drag-width gap))))
                   (when (< ptr-x min-x)
                 (values min-x ptr-y)))
                 (let ((max-x (max 0 (- new-drag-x gap))))
                   (when (< max-x ptr-x)
                 (values max-x ptr-y))))

             (if (minusp delta)
                 (let ((min-y (min (1- height) (+ new-drag-y drag-height gap))))
                   (when (< ptr-y min-y)
                 (values ptr-x min-y)))
                 (let ((max-y (max 0 (- new-drag-y gap))))
                   (when (< max-y ptr-y)
                 (values ptr-x max-y)))))
           (when warp-x
             (warp-pointer slider warp-x warp-y))))))
       t))

      ;; Report final value, if necessary
      (unless (eql 0 update-delay)
        (delete-timer slider :update-delay)
        (apply-callback slider :new-value value))))))))



(defun slider-increment-value (slider scale-increment)
  "Convert the scale-increment to a (possibly) new scale position
and (possibly) cause the slider to be updated."

  (with-slots (value orientation increment minimum maximum update-delay) slider
    ;;  Must use truncate for negative scale-increment's - rounds to zero.
    (let* ((new-value (+ value scale-increment))
       (adjusted  (confine-to (or (apply-callback slider :adjust-value new-value)
                      new-value)
                  minimum maximum)))

      (unless (= value adjusted)   ;; unless no change in slider scale occurs

    (setf (scale-value slider) adjusted) ;; <- this calls scale-update & redisplays slider

    (when (eql 0 update-delay)
      (apply-callback slider :new-value adjusted))))))


(defun slider-handle-motion (slider)
  (declare (special *previous-position*))
  (when (boundp '*previous-position*)
    (with-slots (orientation increment) slider
      (with-event (state x y)
    (multiple-value-bind (ptr-x ptr-y)
        ;;  Is :button-1 still down?
        (if (plusp (logand state #.(make-state-mask :button-1)))

        ;; Yes, query current pointer position
        (pointer-position slider)

        ;; No, use final x,y returned for button transition
        (values x y))

      (let
        ((modulo-increment
           (* (truncate
            (pixels-to-units
              slider
              (if (eq :horizontal orientation)
              (- ptr-x *previous-position*)

              ;; Must swap order of subtraction since positive y direction
              ;; is negative scale direction for :vertical slider
              (- *previous-position* ptr-y)))
            increment)
          increment)))

        ;;  Convert the pixel motion to a suitable slider scale motion
        (unless (zerop modulo-increment)
          (slider-increment-value slider modulo-increment)
          ;;  Use drag-box position. Ptr position is only correct if the drag-box can
          ;;  move to the ptr posiiton without bumping up against the min/max limits.
          (setf *previous-position*
            (if (eq orientation :horizontal)
            (drag-box-center-x slider)
            (translate-x-to-y (drag-box-center-x slider) 1 slider))
            ))))))))

(defun choose-indicator-size (slider)
  "Returns TICK-LIMIT = the number of ticks to draw."
  ;; Called when indicator-size eq :off to automatic tick-marks
  (declare (values tick-limit increments-in-tick))

  (with-slots (maximum minimum increment) slider
    (let* ((tick-mark-thickness (slider-tick-mark-thickness slider))
       (increments-in-tick    1)
       (min-visible-width   (* 2 tick-mark-thickness))
       (ticks               (floor (- maximum minimum) increment))
       )
      ;;  Return appropriate tick-limit
      (values
    (1+     ;; 1+ since we draw the first-tick plus any calculated ticks
      (do* ((ticks-visible nil))
           ((cond
          ((<= ticks 1) (setq ticks-visible 1)) ;; reached minimum ticks, 1 at each end
          ((>= (units-to-pixels slider (* increments-in-tick increment))
               min-visible-width)
           (setq ticks-visible ticks)))
        ;; Exit form
        (return ticks-visible))

        (setq ticks (floor ticks 2)
          increments-in-tick (* 2 increments-in-tick))))

    increments-in-tick ;; 2nd return value
    ))))

;;;----------------------------------------------------------------------------+
;;;                                                                            |
;;;                               Display                                      |
;;;                                                                            |
;;;----------------------------------------------------------------------------+
;;; d1 = first-tick-x
;;; d2 = slidebar-tick-mark-offset
;;;
;;;     min  fill  drag   empty   max
;;; +-----------------------------------+ -
;;; |                                   |  gap
;;; |             +----+                | -
;;; |             |   ||                |  drag-bar-offset
;;; |   .-- ----- |   || -------- --.   | -
;;; |   |** ***** |   ||            |   |  bar-thickness
;;; |   `-- ----- |   || -------- --'   | -
;;; |             |---+|                |
;;; |<----->      +----+                |
;;; | d1  ||        ||           ||     |  bar-text-offset
;;; |   <-->                            |
;;; |     d2                            |
;;; |    MIN                     MAX    |
;;; +-----------------------------------+ -
;;;     ^^ ^     ^       ^       ^^ ^
;;;     || |     |       |       || +-- bar-max-x
;;;     || |     |       |       |+----   (<= last-tick-x MAX-UPPER-EDGE bar-max-x)
;;;     || |     |       |       +----- last-tick-x
;;;     || |     |       +------------- drag-max-edge
;;;     || |     +--------------------- drag-min-edge
;;;     || +--------------------------- first-tick-x
;;;     |+-----------------------------   (<= bar-min-x MIN-LOWER-EDGE first-tick-x )
;;;     +------------------------------ bar-min-x
;;;
;;; Note: No margins are shown except *slider-default-margin*
;;;
;;;
;;;    .--.
;;;    |  |   max
;;;
;;;    |  |
;;;    |  |
;;;    |  |   empty
;;;    |  |
;;;
;;;   +----+
;;;   |    |
;;;   |    |  drag
;;;   |    |
;;;   +----+
;;;
;;;    |**|
;;;    |**|   fill
;;;    |**|
;;;    |**|
;;;
;;;    |**|   min
;;;    `--'
;;;

(defmethod display ((slider slider) &optional at-x at-y at-width at-height &key)
  (with-slots (dimensions width height foreground orientation
              minimum maximum increment middle-length sensitive
              min-text-width max-text-width indicator-size font) slider
    ;; Default exposed rectangle, if necessary
    (setf at-x      (or at-x      0)
      at-y      (or at-y      0)
      at-width  (or at-width  (- width at-x))
      at-height (or at-height (- height at-y)))
    (let* ((drag-box-width  (slidebar-drag-box-width dimensions))
       (drag-bar-offset (slidebar-bar-drag-offset dimensions))
       (gap         (slidebar-gap dimensions))
       (bar-thickness   (slidebar-bar-thickness dimensions))
       (bar-image       (getf (getf *slider-bar-images* :masks) (contact-scale slider)))
       (image-half-size (floor (image-width bar-image) 2))  ;; image is BOTH ends, use min half
       (first-tick-x    (first-tick-x slider))
       (last-tick-x     (+ first-tick-x middle-length))
       (bar-y           (+ (slider-margin slider :top) *slider-default-margin*
                   gap drag-bar-offset))
       (bar-min-x       (- first-tick-x ;; ZRP
                   (slidebar-tick-mark-offset dimensions)))
       (bar-max-x       (+ last-tick-x (slidebar-tick-mark-offset dimensions)))
       (drag-min-edge   (drag-box-min-x slider))
       (drag-max-edge   (+ drag-min-edge gap drag-box-width gap))
       (end-portion     (min image-half-size (max 0 (- drag-min-edge bar-min-x)))) ;; for min end ONLY
       (min-lower-edge  (+ bar-min-x end-portion))
       (max-upper-edge  (max (- bar-max-x image-half-size) drag-max-edge))
       (mask            (contact-image-mask slider bar-image
                        :foreground foreground
                        :background (contact-current-background-pixel slider)))
       (inactive-p      (not (sensitive-p slider)))
       (scale         (contact-scale slider))
       )

      ;; First draw the bar outline, then
      ;; draw the tick-marks, draw the tick-text, and
      ;; finally, fill the bar then blt the drag-box to the correct position.
      (using-gcontext (gc :drawable slider
              :font font
              :exposures :off
              :foreground (if inactive-p
                      (logxor foreground (contact-current-background-pixel slider))
                      foreground)
              :fill-style (when inactive-p :stippled)
              :function   (when inactive-p boole-xor)
              ;; Use 50%gray, since 25%gray looks bad (bar disappears) for args :
              ;; (make-slider :width 200 :height 200 :maximum 4 :orientation :vertical :scale :medium)
              :stipple    (when inactive-p (contact-image-mask slider 50%gray :depth 1))
              :clip-mask  (list at-x at-y at-width at-height)
              )
    ;; Draw MIN end - if it will be visible after drag-box is drawn later.
    ;; The zero reference point (ZRP) is the center of the first tick-mark.
    ;; If at this position we just draw the drag-box at ZRP after subtracting
    ;; the half-width of the drag-box to get the coordinate of the left edge.
    ;; Actually the image blt to the slider also contains a gap, but the ZRP is
    ;; situated such that it centers the drag-box at the extreme min position.

    ;;  Draw (at least part of) MIN
    (when (> drag-min-edge bar-min-x) ;; drag-box is NOT less than gap away from MIN edge
      (multiple-value-bind (src-x src-y -width -height dst-x dst-y)
          (if (eq orientation :horizontal)
          (values 0 0 end-portion (image-width bar-image) bar-min-x bar-y)
          (values 0 (- (image-width bar-image) image-half-size) ;; image may have odd # of pixels
              (image-width bar-image) end-portion
              bar-y (translate-x-to-y bar-min-x end-portion slider)))
        (when (area-overlaps-p at-x at-y at-width at-height dst-x dst-y -width -height)
          (if inactive-p
          (draw-rectangle slider gc dst-x dst-y -width -height :fill-p)
          (copy-area mask gc src-x src-y -width -height slider dst-x dst-y))))

      ;; Draw FILL, if any
      (when (> drag-min-edge min-lower-edge)
        (multiple-value-bind (x y -width -height)
        (if (eq orientation :horizontal)
            (values min-lower-edge bar-y (- drag-min-edge min-lower-edge) bar-thickness)
            (values bar-y (translate-x-to-y min-lower-edge (- drag-min-edge min-lower-edge) slider)
                bar-thickness (- drag-min-edge min-lower-edge)))
        (when (area-overlaps-p at-x at-y at-width at-height x y -width -height)
          (draw-rectangle slider gc x y -width -height :fill-p))))
        )

    ;; Draw EMPTY portion, if any
    (when (> max-upper-edge drag-max-edge)
      (multiple-value-bind (x y x2 y2 x3 y3 x4 y4)
          (if (eq orientation :horizontal)
          (values drag-max-edge bar-y                     ;; x y
              max-upper-edge bar-y                    ;; x2 y2
              drag-max-edge (+ bar-y bar-thickness -1)        ;; x3 y3
              max-upper-edge (+ bar-y bar-thickness -1))        ;; x4 y4
          (values bar-y (translate-x-to-y drag-max-edge 1 slider)    ;; x y
              bar-y (translate-x-to-y max-upper-edge 1 slider)    ;; x2 y2
              (+ bar-y bar-thickness -1) (translate-x-to-y drag-max-edge 1 slider)         ;; x3 y3
              (+ bar-y bar-thickness -1) (translate-x-to-y max-upper-edge 1 slider)))    ;; x4 y4
        (when (area-overlaps-p at-x at-y at-width at-height x y (- x2 x) bar-thickness)
          (draw-segments slider gc (list x y x2 y2 x3 y3 x4 y4))))
      )

      ;; Draw MAX, or portion not obscured by drag-box
    (when (plusp (setq end-portion (min image-half-size (- bar-max-x max-upper-edge))))
      (setq mask (contact-image-mask slider (getf (GETF *slider-bar-images* :borders) scale)
                     :foreground foreground
                     :background (contact-current-background-pixel slider)))
      (multiple-value-bind (src-x src-y -width -height dst-x dst-y)
          (if (eq orientation :horizontal)
          (values (- (image-width bar-image) end-portion) 0
              end-portion (image-width bar-image)
              max-upper-edge bar-y)
          (values 0 0
              (image-width bar-image) end-portion
              bar-y (translate-x-to-y max-upper-edge end-portion slider)))
        (when (area-overlaps-p at-x at-y at-width at-height dst-x dst-y -width -height)
          (if inactive-p
          (draw-rectangle slider gc dst-x dst-y -width -height :fill-p)
          (copy-area mask gc src-x src-y -width -height slider dst-x dst-y))))
      )

    ;; Draw TICK-TEXT, the labels for MIN and MAX
    (unless (eq :off indicator-size) ;; don't draw tick marks or tick text

      (let ((min-thickness (+ (slider-margin slider :top)
                  (fixed-thickness slider :include-text-p nil)))
        (text-x-offset (first  (getf (slidebar-bar-text-offset dimensions) orientation)))
        (text-y-offset (second (getf (slidebar-bar-text-offset dimensions) orientation))))

        (multiple-value-bind (x-min y-min x-max y-max)
        (if (eq orientation :horizontal)
            (values (+ (slider-margin slider :min)
                   text-x-offset
                   ;; center text at :first-tick
                   (+ (first-tick-offset slider)
                  (- (floor min-text-width 2))))
                min-thickness
                (- width
                   (slider-margin slider :max)
                   (last-tick-offset slider)
                   (ceiling max-text-width 2))  ;; scoot left to fit on odd widths!
                min-thickness)
            (values min-thickness
                (+ (slider-margin slider :max)
                   (last-tick-offset slider)
                   middle-length
                   (slidebar-tick-mark-offset dimensions)
                   (- gap))
                min-thickness
                (+ (slider-margin slider :max)
                   (last-tick-offset slider)
                   (- (slidebar-tick-mark-offset dimensions))
                   text-y-offset)))
          (let* ((font-ascent (max-char-ascent font))
             (font-height (+ font-ascent (max-char-descent font))))
        (when (if (eq orientation :horizontal)
              (area-overlaps-p at-x at-y at-width at-height
                       x-min (- y-min font-ascent)
                       (+ (- x-max x-min) max-text-width)
                       font-height)
              (area-overlaps-p at-x at-y at-width at-height
                       x-max (- y-max font-ascent)
                       (max min-text-width max-text-width)
                       (+ (- y-min y-max) font-height)))
          ;; Draw TICK-TEXT for min and max
          (draw-glyphs slider gc x-min y-min (format nil "~a" minimum))
          (draw-glyphs slider gc x-max y-max (format nil "~a" maximum))))))

      ;; Draw TICK-MARKS
      (multiple-value-bind (tick-limit increments-in-tick)
          (if (plusp indicator-size)
          (values (1+ (floor (- maximum minimum) (* increment indicator-size)))
              indicator-size)
          (choose-indicator-size slider)) ;; automatic tick marks
        (do* ((tick 0 (incf tick))
          (tick-thickness (slider-tick-mark-thickness slider))
          (tick-x (+ (first-tick-x slider) (- (floor tick-thickness 2))) ;; adjust from center to edge of tick
              (+ (first-tick-x slider) (- (floor tick-thickness 2))
                 (units-to-pixels slider (* tick increments-in-tick increment))))
          (tick-y (+ (slider-margin slider :top)
                 (bar-bottom-offset slider)
                 (slider-bar-tick-gap slider)))
          (tick-height (slidebar-tick-mark-length dimensions)))

         ((= tick tick-limit)) ;; draw tick @min plus TICK-LIMIT more

          (multiple-value-bind (x y -width -height)
          (if (eq orientation :horizontal)
              (values tick-x tick-y
                  tick-thickness tick-height)
              (values tick-y (translate-x-to-y tick-x tick-thickness slider)
                  tick-height tick-thickness))
        (when (area-overlaps-p at-x at-y at-width at-height x y -width -height)
          (draw-rectangle slider gc x y -width -height :fill-p)
          ))))
      )

    ;; Draw DRAG BOX (possibly over a tick mark)
    (let ((drag-image (getf (getf *slider-drag-box-images* orientation) scale)))
      (setq mask (contact-image-mask slider drag-image
                     :foreground foreground
                     :background (contact-current-background-pixel slider)))
      (multiple-value-bind (src-x src-y -width -height dst-x dst-y)
          (if (eq orientation :horizontal)
          (values 0 0 (image-width drag-image) (image-height drag-image)
              drag-min-edge (- bar-y drag-bar-offset gap))
          (values 0 0 (image-width drag-image) (image-height drag-image)
              (- bar-y drag-bar-offset gap)
              (translate-x-to-y drag-min-edge (image-height drag-image) slider)))
        (when (area-overlaps-p at-x at-y at-width at-height
                   dst-x dst-y -width -height)

          (if inactive-p
          (draw-rectangle slider gc dst-x dst-y -width -height :fill-p)
          (copy-area mask gc src-x src-y -width -height slider dst-x dst-y))
          (when (boundp '*highlight-pixel*)
        (special-highlite-drag-box slider gc dst-x dst-y -width -height gap)))))))))

;;; Crock! This function could be inlined, except that causes the Explorer compiler
;;; to barf on (method display (slider)) when using R4 CLX.
(defun special-highlite-drag-box (slider gc dst-x dst-y -width -height gap)
  (declare (special *highlight-pixel*))
  (with-gcontext (gc :function boole-xor :foreground *highlight-pixel*)
    ;; Highlight drag area while button is still down )
    (highlite-drag-box slider gc dst-x dst-y -width -height gap)))